サンプル[6]
HTML File＜＞以外の文字検索(2000用)
(1).このプログラムの使用方法
[1]ダイアログが表示されたらチェックしたいHTMLファイルを指定する。
[2]HTMLファイルの下図ソ−スを表示（一瞬表示される）
[3]抽出したい文字を指定する
[4]上記のダイアログ「OK」で下図のように、抽出した文字が
シ−ト「検索結果」に表示される。
２．ソ−スの表示
'「ＨＴＭＬファイルの単語抽出」プログラム
' KImozi2000 Vea0.1
'下記"C:\windows\temp"はPCにより異なります
'TEMPファイルある場所に変更してから使用して下さい。
'
Const phn1 As String = "C:\windows\temp" '仮の保存場所
Dim cen1 As Integer '最終セル
Dim ra As Integer 'ロウno(HTML側）
Dim rb As Integer 'ロウno(張付側）
Dim i As Integer '数字カウント
Dim sname As String 'シ−ト名
Dim fff As String 'ファイル名
Dim moz1 As String '抽出する文字
Dim moz2 As String '抽出された文字
Dim ssa As Integer 'ファイルサイズa
'
Sub moziselect()
'ダイアログ表示
fff = Application.GetOpenFilename(Title:="HTMLタグをチェックするファイル指定")
If fff = "False" Then
MsgBox "ファイルを１個指定して下さい"
Exit Sub
End If
'拡張子
i = InStrRev(fff, ".")
ext = Mid(fff, i)
If InStr(1, ext, "htm", 1) = 0 Then
MsgBox "拡張子「html」or「htm」以外は指定出来ません"
Exit Sub
End If
FileCopy fff, phn1 & "\htmlcheck.txt"
Workbooks.Add
With ActiveSheet.QueryTables.Add(Connection:= _
"TEXT;" & phn1 & "\htmlcheck.txt", Destination:=Range("A1"))
.Name = "htmlcheck"
.RefreshStyle = xlInsertDeleteCells
.RefreshPeriod = 0
.TextFilePlatform = xlWindows
.TextFileStartRow = 1
.TextFileParseType = xlDelimited
.TextFileTextQualifier = xlTextQualifierNone
.TextFileColumnDataTypes = Array(1)
.Refresh BackgroundQuery:=False
End With
'最終セル
sname = ActiveSheet.Name
ActiveCell.SpecialCells(xlLastCell).Select
cen1 = ActiveCell.Row
Range("A1").Select
'＜＞をカット
Cells.Replace What:="<*>", Replacement:="", LookAt:=xlPart, _
SearchOrder:=xlByRows, MatchCase:=False
'
Application.ScreenUpdating = False
Application.StatusBar = True
'単語チェック
msg = "抽出したい文字を入力して下さい。"
moz1 = Application.InputBox(msg, "単語抽出", Type:=2)
For ra = 1 To cen1
Sheets(sname).Select
Application.StatusBar = "タグチェック中 -- " & i & " / " & cen1
dat = Cells(ra, 1)
ssa = InStr(1, dat, moz1, 1)
If ssa > 0 Then
moz2 = Mid(dat, ssa)
張付
End If
Next
Application.StatusBar = moz1 & "を " & rb - 1 & "個抽出しました"
Sheets("検索結果").Select
End Sub
'
Sub 張付()
sck = 0
For Each sheet_name In Worksheets
If sheet_name.Name = ("検索結果") Then
sck = 1
Exit For
End If
Next
'
If sck = 0 Then
Sheets.Add.Name = "検索結果"
rb = 1
End If
Sheets("検索結果").Select
Cells(rb, 1) = moz2
rb = rb + 1
End Sub
３．その他
上記ソ−スを、Excel2000の「標準モジュ−ル」へ貼り付けて使用できます。
他人への譲渡もＯＫで自由に使用して下さい。(ただし著作権は放棄していない）
目次へ戻る